home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
yerk 3.66
/
System source
/
Files
< prev
next >
Wrap
Text File
|
1994-06-24
|
15KB
|
504 lines
\ Files - file object and loader
\ 09/10/84 CBD Version 1.0
\ 10/12/84 CBD Added loader, Length: -> bytesRead:
\ 12/14/84 cbd nested loads, no default:
\ 7/04/86 cdn Added HFS references
\ 7/13/86 cdn Moved in SFPReply
\ 8/15/86 rfd Skip HFS search is vRefNum supplied
\ 8/26/86 cdn Added classinit for File
\ 9/8/86 rfd added dirfind resfind etc. to speed up open
\ 12/3/87 rfl fixed pileup of pathnames in hopen
\ 12/3/87 rfl addef flushvol:
\ 9/5/88 rfl fixed hfs?
\ 12/14/88 rfl fixing data record for hfs
\ 5/23/90 rfl added event processing during file loading
\ 7/25/90 rfl fixed load so that ?pause works during +echo
\ 9/27/90 rfl savesig now finds app signature
\ 11/12/90 rfl recoded volname?
\ 12/14/90 rfl added font change to //
\ 12/29/90 rfl mods for path now sarray object
\ 1/31/91 rfl fixed saveSig to get signature, not file name; font stuff now
\ here; no longer need chicago 9.
\ 1/26/92 rfl fixed Savesig to use heap file object. remove: loadfile closed the file.
\ This wasn't good if the file was the standalone application.
\ 11/25/92 rfl Changed Last: to look at file size instead of using $ ffffff.
\ 12/11/92 rfl pulled ftype out of file, now global; added put: for single character write
\ removed antiquated words like sony, external, profile; added where:
\ 4/30/93 rfl Now when saving a snapshot of the environment, you no longer
\ have to worry about closing the windows. The open windows are first marked
\ closed, the file is saved, then they are all marked open again
\ 5/10/93 rfl shortened filinit
\ 5/12/93 rfl Hopen: and orf now lock down strings because of occasional problems
\ not building search path correctly due to moving of data
\ 5/17/93 rfl removed res string call from clear: filelist so yerk.rsrc not
\ necessary for string
\ 6/04/93 rfl modified for source documentation; sfind and screate moved from 'mod'
\ 6/17/93 rfl srcCreate now replaces a filemark with no yerk words defined after it.
\ 1/01/94 rfl incorporated file related words from base and put into class file as methods
Decimal
\ ( n fcb(abs) -- )
Create dirfind
popA0
popD0
$ A260 w,
pushD0
next,
: volname? { strobj -- b }
start: strobj next: strobj
IF ascii : <> ELSE false THEN ;
0 -> quitvec \ leave vectors in a clean state
0 -> abortvec
: (nevent1) decho IF ?pause THEN ;
'c (nevent1) vect nEvent \ use as stub until Event is loaded
: -echo false -> decho ;
: +echo true -> decho ;
: -curs false -> curs ;
: +curs true -> curs ;
\ ( -- T or F ) returns true if on HFS
: hfs? $ 3f6 -base w@ 0> ;
0 value path \ is instantiated by getPtxt
\ Strip volume name & HFS paths from a file name
: MFSname { addr len -- addr' len' }
len ++> addr
len 0
DO -1 ++> addr \ scan through string backwards
addr c@ ascii : = \ first colon we see, we stop
IF 1 ++> addr i -> len leave THEN
LOOP
addr len
;
: UpCase true -> ucase ;
: LoCase false -> ucase ;
\ ( addr len -- pfa len t OR f ) find word for name on stack. map to uppercase
\ by default, but if ucase is false, then leave text alone.
: sfind here >str255 ucase
IF 1+ here c@ >uc here ELSE -base THEN latest (find) ;
\ ( addr len -- ) create a new dict name/link for name on stack
: sCreate docs IF line# w, THEN \ for source documentation
sfind IF here count type type# 184 ( is redefined ) cr 2drop THEN
createHdr -4 allot ;
\ don't allow two adjacent words to be file marks...this will
\ prevent a load file from being embedded in the dictionary...unless the
\ loadfile begins by defining yerk words...thus a loadfile cannot do any
\ defining for this to work all the time.
: srcCreate ( addr len -- ) \ create a filemark entry to dictionary
docs
IF dup 31 > ?error 187
latest name> @ fileMk = \ is the last word a filemark?
IF latest dup >line -> dp pfa lfa @ current ! THEN \ yes, so get rid of it
LoCase
screate
fileMk ,
UpCase
ELSE 2drop
THEN ;
4 Ordered-Col fTypes \ list of filetypes used by all files for stdget:
:CLASS File <Super Object
134 Bytes FCB \ max MAC parameter block(108 but for hgetvinfo)
\ Standard File data
Int Good \ this is like a variable record
Var fType
Int vRefNum
Int Version
64 Bytes Filename \ max size is 64
\ ( --) Set the NamePtr field to the abs address of the file name field
:M SETNAMEPTR: (abs) 144 + ^base 18 + ! ;M
:M CLEAR: \ Erase a parm block
^base 144 erase ^base 144 + 64 blanks setNamePtr: self ;M
:M CLOSE: ^base (close) ;M
\ ( addr len -- ) assigns file name to fcb
:M NAME: clear: self ^base swap 64 min swap 144 + >str255 drop ;M
\ ( dirid -- ) set the DirID for the fcb
:M SETDIRID: ^base 48 + ! ;M
\ ( -- dirid ) get the DirID for the fcb
:M GETDIRID: ^base 48 + @ ;M
\ ( vref# -- ) set the volRefNum for the fcb
:M SETVREF: ^base 22 + w! ;M
\ ( -- vref# ) get the volRefNum for the fcb
:M GETVREF: ^base 22 + w@ ;M
\ ( mode -- fCode )
:M HOPEN: { mode \ fnam1 pathname rc -- }
path IF lock: path THEN
heap> String -> fnam1 new: fnam1
heap> String -> pathName new: pathName
addr: filename count put: fnam1
lock: fnam1
start: fnam1 path
IF ascii : charOf: fnam1
IF drop ^base mode (open) \ assumed to be qualified path name
ELSE
limit: path 0
DO i at: path put: pathname
pathname volname? 0= hfs? land
IF lock: pathname \ if not volume
get: pathname name: self unlock: pathname \ get dirid
9 ^base +base dirfind drop
getdirid: self
get: fnam1 name: self
setdirid: self
^base mode (open) -> rc \ attempt to open
rc 0= IF leave THEN \ found it !!
ELSE
pathName concat: fnam1
lock: pathname get: pathname name: self unlock: pathname
^base mode (open) -> rc
rc 0= IF leave THEN \ found it !!
THEN
LOOP
rc IF get: fnam1 name: self THEN
rc \ leave return code
THEN
ELSE
hfs? 0= \ strip HFS paths under MFS
IF ascii : charOf: fnam1
IF >R 0 -base \ setup for replace:
get: fnam1 MFSname drop ptr: fnam1 R + -
" :" drop R> 0> replace: fnam1 \ delete any path spec
get: fnam1 addr: filename >str255 drop
THEN
THEN
^base mode (open)
THEN
release: fnam1 dispose> fnam1
release: pathname dispose> pathname
path IF unlock: path THEN
;M
\ ( -- fcode ) basic I/O operations
:M OPEN:
^base 22 + w@ ^base 48 + @ or
IF ^base 0 (open)
ELSE 0 Hopen: self THEN
;M
:M NEW: ^base (make) ;M
:M DELETE: ^base (delete) ;M
\ ( byteoffset -- fcode ) position relative to beginning-of-file
:M MOVETO: ^base 1 rot (lseek) ;M
\ ( -- byteoffset ) current position relative to beginning-of-file
:M WHERE: ^base 46 + @ ;M
\ ( pos -- fcode ) set End-of-File to absolute byte position
:M SETEOF: ^base 28 + ! ^base $ a012 (fdos) ;M
\ ( -- fcode ) open and reset file or create new if not present
:M CREATE: { \ volid -- fcode }
^base 22 + w@ -> volid
open: self
-dup
IF dup -43 =
volid ^base 22 + w!
IF drop
new: self -dup
0= IF ^base 0 (open) THEN
THEN
ELSE
0 setEOF: self
THEN
;M
\ ( -- #bytes ) return logical eof for file currently open
:M SIZE: ^base $ a011 (fdos) drop ^base 28 + @ ;M
\ ( -- ) position to file's eof
:M LAST: size: self moveTo: self drop ;M
\ ( -- lengthRead ) return actual bytes read
:M BYTESREAD: ^base 40 + @ ;M
\ ( -- fcbAddr )
:M FCB: ^base ;M
\ ( -- fcode )
:M RESULT: addr: fcb 16 + W@ ;M
\ ( posMode -- ) Set position mode
:M MODE: ^base 44 + W! ;M
\ ( addr length -- fcode )
:M READ: 0 mode: Self ^base swap rot (read) ;M
\ ( addr maxLen -- fcode ) Read terminating with CR
:M READLINE: $ 0d80 Mode: self ^base swap rot (read) ;M
\ ( addr length -- fcode )
:M WRITE: ^base swap rot (write) ;M
\ ( n -- fcode )
:M PUT: pad c! pad 1 write: self ;M
\ ( -- ) Get name from input stream, and assign to fcb
:M SETNAME: word" count Name: self ;M
\ ( -- addr len ) return filename
:M GETNAME: addr: fileName count ;M
\ ( -- ) print the filename
:M PRINT: getName: self type ;M
\ ( drive# -- ) set default drive to drive#
:M DRIVE: Clear: self setVRef: self ^base $ a015 (fdos)
?error 165 ;M \ Drive change unsuccessful
\ ( addr len -- eof ) Simulate a Yerk expect from disk
:M EXPECT: { addr len -- }
addr len 1+ erase addr len ReadLine: self 0=
IF dEcho
IF addr bytesRead: self 1+ type cr
THEN
addr bytesread: self + 1- 0 swap c! 0
ELSE 1 THEN ;M
\ ( -- eof ) Expect a line to the TIB
:M QUERY: 0 -> in Tib 128 Expect: self 1 ++> line# ;M
\ interpret the file as a Yerk source file
\ ( -- ) name must first be set
:M INTERPRET: { \ icurs -- } -1 -> line#
open: self classErr" 132
getName: self
srcCreate \ create file mark entry
curs -> icurs -curs \ Preserve cursor status
BEGIN nEvent
query: self 0=
WHILE Interpret State 0= dEcho And
IF ok THEN
REPEAT ?exec close: self drop
icurs -> curs -1 -> line# ;M \ Restore cursor status
:M FLUSHVOL: ^base $ A013 (fdos) drop ;M
\ ( taddr tlen -- fcode )
:M RENAME: { taddr tlen -- result }
taddr tlen str255
^base 28 + ! ^base $ A00B (fdos) ;M
\ ( -- fcode )
:M OPENREADONLY:
^base 22 + w@ ^base 48 + @ or
IF ^base 1 (open)
ELSE 1 Hopen: self THEN ;M
\ ( -- type )
:M GETTYPE: ^base 32 + @ ;M
\ ( -- fcode ) fills the parameter block with file info
:M GETFILEINFO: ^base $ A20C (fdos) ;M
\ ( -- fcode )
:M SETFILEINFO: ^base $ A00D (fdos) ;M \ immed doesn't work for some reason
\ ( ftype sig -- ) Set file type, signature
:M SET: { ftyp sig -- } \ Sets file type, signature - recoded file-install
getDirID: self \ Save DirID
0 setDirID: self \ and clear it (otherwise we'll get
getFileInfo: self drop \ "file not found")
sig ^base $ 24 + ! \ Set signature
ftyp ^base $ 20 + ! \ Set type
0 setDirID: self
setFileInfo: self drop
setDirID: self \ Restore DirID
flushVol: self ;M
\ ( routine# -- bool ) call a Standard File Package routine
:M SFPCALL: makeInt $ a9ea Trap
get: good
IF get: vRefNum ^base 80 erase setNamePtr: self
setVref: self True
ELSE False
THEN ;M
\ ( type0 ...typeN #types -- bool ) call SFGetFile
:M STDGET: clear: fTypes dup 0>
IF 0 DO add: fTypes LOOP
ELSE drop THEN
$ 640064 0 0 size: fTypes -dup 0= IF -1 THEN makeInt
ixAddr: fTypes +base 0 abs: good
2 sfpCall: self ;M
\ call SFPutFile - takes promp, origName strings
:M STDPUT: { pAddr pLen nAddr nLen -- bool }
pLen pad c! pAddr pad 1+ pLen cmove
$ 640064 pad +base nAddr nLen str255 0 abs: good
1 sfpCall: self ;M
:M CLASSINIT: clear: self ;M
;CLASS
' File 'c fFcb ! \ set ffcb to member of file class
\ FileList keeps a stack of open load files for nested loads.
:CLASS FileList <Super Ordered-Col
\ release heap for the top element
:M REMOVE: get: size dup 0= classerr" 137
1- ^elem close: [ dup @ ] drop
dispose -1 +: size ;M
\ ( -- ^file ) add a new file to the stack
:M NEW: heap> file add: super ;M
\ interpret the top file
:M INTERPRET: interpret: [ last: self ] ;M
\ ( -- ) remove all currently open files
:M CLEAR: ." File stack: " cr \ type# 180 ( File stack: ) cr
get: size 0
DO print: [ last: self ] cr remove: self
LOOP ;M
\ ( -- ) initialize list at startup
:M INIT: clear: super ;M
;CLASS
6 fileList loadFile
: lastLoad last: loadFile ;
'c lastLoad vect topFile
\ ( addr len -- ) open named resource file
: orf { \ fnam1 pathname RC nfcb -- }
new: loadFile name: topFile
word0 getname: topfile str255 $ a997 trap i->l -1
= IF
HFS? path land IF
HEAP> String -> fnam1 new: fnam1
heap> string -> pathName new: pathName
getname: topfile put: fnam1 lock: fnam1
-1 -> RC
HEAP> file -> nfcb
limit: path 0 DO
i at: path put: pathname
start: fnam1 get: fnam1 add: pathname
lock: pathname get: pathname
name: nfcb 9 nfcb +base dirfind
0= IF nfcb 30 + c@ 16 and ELSE true Then not
IF
word0 get: pathname STR255
$ a997 trap i->l -> RC
LEAVE
THEN unlock: pathname
LOOP
Dispose> nfcb
release: pathname dispose> pathname
release: fnam1 dispose> fnam1
ELSE word0 getname: topfile STR255 $ a997 trap i->l -> rc
THEN RC -1 = abort" resource file open failed"
THEN remove: loadfile
;
\ ( addr len - )
:F OpenResFile ORF ;F
\ used to be defined in Event
\ ( val -- ) set text characteristics for current grafPort
: tfont makeint $ a887 trap ;
: tFace makeInt $ a888 trap ;
: tMode makeInt $ a889 trap ;
: tSize makeInt $ a88a trap ;
\ nesting loader. Use: // filename
: // { \ lcurs -- }
curs -> lcurs -curs \ Preserve cursor status
new: loadFile setName: topFile
getName: topFile 3 tfont 1 tface type# 173 ( Loading: ) type 0 tface 4 tfont cr
interpret: topFile remove: loadFile
lcurs -> curs ; \ Restore cursor status
\ ================ Save ====================
'type COM CONSTANT saveType \ file type = 'COM '
\ use current application signature
: saveSig { \ myFile -- }
heap> file -> myFile \ need a file structure
$ 910 -base count name: myFile \ get nucleus name
getFileInfo: myFile drop \ get info
myFile 36 + @ dispose> myFile ; \ get signature
( -- Length of dictionary to be saved )
: flen here Begin-dp @ - ;
Forward purge \ defined in Ovl
0 Variable H1 here 16 allot 16 erase
\ mark all windows closed
: togWindows { flag \ theWindow -- } 0 $ a924 trap
BEGIN -base -> theWindow
theWindow $ 90 + @ \ get next window in list
flag theWindow 184 + w! ( markClosed: theWindow ) dup 0= \ continue until no more windows
UNTIL drop ;
: markWindowsClosed 0 togWindows ;
: markWindowsOpen 1 togWindows ;
\ Reuse target BIN file- so as not to wrestle file from it's folde
\ ( -- ) Save the user dictionary
: (Save) markWindowsClosed
purge
path 0 -> path \ temporarily zero out path
setNamePtr: ffcb
create: fFcb ?error 107
\ SAVE-HEAD
here H1 ! \ Save DP
fence H1 4+ ! \ Save FENCE
voc-link H1 8+ ! \ Save VOC-LINK
latest H1 12 + ! \ Save latest NFA
0 mode: fFcb 0 fFcb 46 + w!
H1 16 write: fFcb ?error 101
\ WRITE-DICT
$ 10 fFcb $ 2E + W!
begin-dp @ flen write: fFcb ?error 105
saveType saveSig set: fFcb
close: fFcb drop
-> path \ restore path
markWindowsOpen ;
\ Save command takes name from input stream
: Save
setName: fFcb (save) ;
\ when // executes, it adds a new file object on the heap to a
\ stack of files. This permits embedded loads, providing hierarchical
\ nesting of source files.
: cleanUp [Compile] ;class clear: loadFile init8 parmlist -1 -> line# ;
: filinit ' File 'c fFcb ! init: loadFile ;
'c filinit -> objinit
'c cleanUp -> abortvec
'type TEXT constant txType
\ true -> docs
// tool.load